{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit ClassifyQuestion;

interface

uses
  Classes, SysUtils, MiscUtils, TestCore, SecureRandom, Pad, TestUtils;

type
  TClassifyCategory = class
  private
    FTitle: TPad;
    FItems: TPadGroup;
  public
    constructor Create;
    destructor Destroy; override;
    function ReplaceString(const OldString, NewString: String): Integer;
    procedure Assign(Source: TClassifyCategory);
    function Clone: TClassifyCategory;

    property Items: TPadGroup read FItems;
    property Title: TPad read FTitle;
  end;
  TClassifyCategoryList = TGenericObjectList<TClassifyCategory>;

  TClassifyResponse = class(TResponse)
  private
    FAnswer: TIntegerArray;
  public
    procedure SetAnswer(const Value: TIntegerArray);
    function GetAnswer: TIntegerArray;
    procedure Assign(Source: TResponse); override;
  end;

  TClassifyQuestion = class(TQuestionWithFormulation)
  private
    FCategories: TClassifyCategoryList;
    FRight: TPadGroup; { used in produced question only }
    FItemLimit: Integer; { 0 = all }
    FMinItemsPerCategory: Integer;
    function GetCategoryCount: Integer;
    procedure CheckCategoryIndex(Index: Integer);
    function GetCategories(Index: Integer): TClassifyCategory;
    function GetItemCount: Integer;
    procedure SetItemLimit(Value: Integer);
    procedure SetMinItemsPerCategory(Value: Integer);
  public
    constructor Create; override;
    destructor Destroy; override;
    class function GetResponseClass: TResponseClass; override;
    class procedure Spawn(var Question: TQuestion; Alterants: TAlterantList); override;
    class function Kind: TKind; override;
    function IsResponseCompatible(Candidate: TResponse): Boolean; override;
    function Evaluate(Candidate: TResponse): Single; override;
    procedure AddCategory(Category: TClassifyCategory);
    procedure Filter; override;
    procedure Assign(Source: TQuestion); override;
    function ReplaceString(const OldString, NewString: String): Integer; override;
    function Response: TClassifyResponse;

    property Categories[Index: Integer]: TClassifyCategory read GetCategories;
    property CategoryCount: Integer read GetCategoryCount;
    property ItemCount: Integer read GetItemCount;
    property ItemLimit: Integer read FItemLimit write SetItemLimit;
    property MinItemsPerCategory: Integer read FMinItemsPerCategory write SetMinItemsPerCategory;
    property Right: TPadGroup read FRight;
  end;

  TClassifyPlacementInfo = record
    CategoryIndex: Integer;
    ItemIndex: Integer;
  end;
  TClassifyPlacementInfoArray = array of TClassifyPlacementInfo;

  TSpawnClassifyQuestionAlterant = class(TAlterant)
  private
    FPlacement: TClassifyPlacementInfoArray;
  public
    procedure Apply(var Question: TQuestion); override;
    function GetPlacement: TClassifyPlacementInfoArray;
    procedure SetPlacement(const Value: TClassifyPlacementInfoArray);
  end;

implementation

type
  TAvailableCategory = class
  private
    FCategoryIndex: Integer;
    FAvailableItems: TIntegerList;
  public
    constructor Create;
    destructor Destroy; override;
  end;
  TAvailableCategoryList = TGenericObjectList<TAvailableCategory>;

{ TAvailableCategory }

constructor TAvailableCategory.Create;
begin
  inherited;
  FAvailableItems := TIntegerList.Create;
end;

destructor TAvailableCategory.Destroy;
begin
  FreeAndNil(FAvailableItems);
  inherited;
end;

{ TClassifyQuestion }

procedure TClassifyQuestion.AddCategory(Category: TClassifyCategory);
begin
  FCategories.AddSafely(Category);
end;

procedure TClassifyQuestion.CheckCategoryIndex(Index: Integer);
begin
  Assert( Index >= 0 );
  Assert( Index < CategoryCount );
end;

constructor TClassifyQuestion.Create;
begin
  inherited;
  FCategories := TClassifyCategoryList.Create;
  FRight := TPadGroup.Create;
end;

destructor TClassifyQuestion.Destroy;
begin
  FreeAndNil(FCategories);
  FreeAndNil(FRight);
  inherited;
end;

function TClassifyQuestion.IsResponseCompatible(
  Candidate: TResponse): Boolean;
var
  Answer: TIntegerArray;
  i: Integer;
begin
  Result := Candidate is TClassifyResponse;
  if Result then
  begin
    Answer := TClassifyResponse(Candidate).GetAnswer;
    Result := Length(Answer) = Length(Response.GetAnswer);
    if Result then
    begin
      for i := 0 to High(Answer) do
        if (Answer[i] < -1) or (Answer[i] >= CategoryCount) then
        begin
          Result := FALSE;
          Break;
        end;
    end;
  end;
end;

function TClassifyQuestion.Evaluate(Candidate: TResponse): Single;
var
  CandidateAnswer: TIntegerArray;
begin
  CheckResponseCompatible(Candidate);
  CandidateAnswer := TClassifyResponse(Candidate).GetAnswer;
  if LaxEvaluation then
    Result := EvaluateMappingLaxly(Response.GetAnswer, CandidateAnswer)
  else
    Result := EvaluateMappingDichotomically(Response.GetAnswer, CandidateAnswer);
end;

procedure TClassifyQuestion.Filter;
var
  NullAnswer: TIntegerArray;
  i: Integer;
begin
  inherited;
  SetLength(NullAnswer, Length(Response.GetAnswer));
  for i := 0 to High(NullAnswer) do
    NullAnswer[i] := -1;
  Response.SetAnswer(NullAnswer);
  
  ItemLimit := 0;
  MinItemsPerCategory := 0;
end;

procedure TClassifyQuestion.Assign(Source: TQuestion);
var
  q: TClassifyQuestion;
  c: TClassifyCategory;
begin
  inherited;
  q := Source as TClassifyQuestion;

  FCategories.Clear;
  for c in q.FCategories do
    AddCategory(c.Clone);

  FRight.Assign(q.FRight);
  FItemLimit := q.FItemLimit;
  FMinItemsPerCategory := q.FMinItemsPerCategory;
end;

function TClassifyQuestion.GetCategories(Index: Integer): TClassifyCategory;
begin
  CheckCategoryIndex(Index);
  Result := FCategories[Index];
end;

function TClassifyQuestion.GetCategoryCount: Integer;
begin
  Result := FCategories.Count;
end;

function TClassifyQuestion.GetItemCount: Integer;
var
  c: TClassifyCategory;
begin
  Result := 0;
  for c in FCategories do
    Inc(Result, c.Items.Count);
end;

function TClassifyQuestion.Response: TClassifyResponse;
begin
  Result := TClassifyResponse(inherited);
end;

class function TClassifyQuestion.GetResponseClass: TResponseClass;
begin
  Result := TClassifyResponse;
end;

function TClassifyQuestion.ReplaceString(const OldString,
  NewString: String): Integer;
var
  c: TClassifyCategory;
begin
  Result := inherited;
  for c in FCategories do
    Inc(Result, c.ReplaceString(OldString, NewString));
  Inc(Result, FRight.ReplaceString(OldString, NewString));
end;

procedure TClassifyQuestion.SetItemLimit(Value: Integer);
begin
  Assert( Value >= 0 );
  FItemLimit := Value;
end;

procedure TClassifyQuestion.SetMinItemsPerCategory(Value: Integer);
begin
  Assert( Value >= 0 );
  FMinItemsPerCategory := Value;
end;

class procedure TClassifyQuestion.Spawn(var Question: TQuestion;
  Alterants: TAlterantList);
var
  Alterant: TSpawnClassifyQuestionAlterant;
  Placement, ShuffledPlacement: TClassifyPlacementInfoArray;
  i: Integer;
  ClassifyQuestion: TClassifyQuestion;
  p: TIntegerArray;

  procedure ChooseAllItems;
  var
    i, j, n: Integer;
  begin
    SetLength(Placement, ClassifyQuestion.ItemCount);
    n := 0;
    for i := 0 to ClassifyQuestion.CategoryCount-1 do
      for j := 0 to ClassifyQuestion.Categories[i].Items.Count-1 do
      begin
        Placement[n].CategoryIndex := i;
        Placement[n].ItemIndex := j;
        Inc(n);
      end;
  end;

  procedure ChooseSpecifiedItemCount;
  var
    AvailableCategories: TAvailableCategoryList;
    c: TAvailableCategory;
    i, j: Integer;

    function ChooseItem(AvailableCategoryIndex: Integer): Boolean;
    var
      ItemList: TIntegerList;
      n: Integer;
    begin
      ItemList := AvailableCategories[AvailableCategoryIndex].FAvailableItems;
      n := SecureRandomInteger(ItemList.Count);

      SetLength(Placement, Length(Placement) + 1);
      Placement[High(Placement)].CategoryIndex := AvailableCategories[AvailableCategoryIndex].FCategoryIndex;
      Placement[High(Placement)].ItemIndex := ItemList[n];

      ItemList.Delete(n);
      Result := ItemList.Count > 0;
      if not Result then
        AvailableCategories.Delete(AvailableCategoryIndex);
    end;

  begin
    AvailableCategories := TAvailableCategoryList.Create;
    try
      for i := 0 to ClassifyQuestion.CategoryCount-1 do
      begin
        if ClassifyQuestion.Categories[i].Items.Count > 0 then
        begin
          c := AvailableCategories.AddSafely(TAvailableCategory.Create);
          c.FCategoryIndex := i;
          for j := 0 to ClassifyQuestion.Categories[i].Items.Count-1 do
            c.FAvailableItems.Add(j);
        end;
      end;
      SetLength(Placement, 0);

      { Choose the specified minimum number of items from each category. }
      for i := AvailableCategories.Count-1 downto 0 do
        for j := 0 to ClassifyQuestion.FMinItemsPerCategory-1 do
          if not ChooseItem(i) then { i-th category exhausted, move on to the next }
            Break;

      { Choose the remaining items from random categories. }
      while (Length(Placement) < ClassifyQuestion.FItemLimit) and (AvailableCategories.Count > 0) do
        ChooseItem(SecureRandomInteger(AvailableCategories.Count));
    finally
      AvailableCategories.Free;
    end;
  end;
  
begin
  inherited;
  Assert( Question is TClassifyQuestion );
  ClassifyQuestion := TClassifyQuestion(Question);
  Alterant := TSpawnClassifyQuestionAlterant.Create;
  Alterants.Add(Alterant);

  if ClassifyQuestion.ItemLimit = 0 then
    ChooseAllItems
  else
    ChooseSpecifiedItemCount;

  if Length(Placement) > 0 then
  begin
    p := GenerateRandomPermutation(Length(Placement), SecureRandomInteger);
    SetLength(ShuffledPlacement, Length(Placement));
    for i := 0 to High(Placement) do
      ShuffledPlacement[i] := Placement[p[i]];
  end
  else
    ShuffledPlacement := nil;
  Alterant.SetPlacement(ShuffledPlacement);

  Alterant.Apply(Question);
end;

class function TClassifyQuestion.Kind: TKind;
begin
  Result := $524d0542e4309848;
end;

{ TClassifyResponse }

function TClassifyResponse.GetAnswer: TIntegerArray;
begin
  Result := Copy(FAnswer);
end;

procedure TClassifyResponse.Assign(Source: TResponse);
begin
  inherited;
  FAnswer := Copy((Source as TClassifyResponse).FAnswer);
  Changed;
end;

procedure TClassifyResponse.SetAnswer(const Value: TIntegerArray);
begin
  FAnswer := Copy(Value);
  Changed;
end;

{ TClassifyCategory }

constructor TClassifyCategory.Create;
begin
  inherited;
  FTitle := TPad.Create;
  FItems := TPadGroup.Create;
end;

destructor TClassifyCategory.Destroy;
begin
  FreeAndNil(FTitle);
  FreeAndNil(FItems);
  inherited;
end;

function TClassifyCategory.ReplaceString(const OldString,
  NewString: String): Integer;
begin
  Result :=
    FTitle.ReplaceString(OldString, NewString) +
    FItems.ReplaceString(OldString, NewString);
end;

procedure TClassifyCategory.Assign(Source: TClassifyCategory);
begin
  FTitle.Assign(Source.FTitle);
  FItems.Assign(Source.FItems);
end;

function TClassifyCategory.Clone: TClassifyCategory;
begin
  Result := TClassifyCategory.Create;
  try
    Result.Assign(Self);
  except
    Result.Free;
    raise;
  end;
end;

{ TSpawnClassifyQuestionAlterant }

procedure TSpawnClassifyQuestionAlterant.Apply(var Question: TQuestion);
var
  ClassifyQuestion: TClassifyQuestion;
  i: Integer;
  Answer: TIntegerArray;
begin
  Assert( Question is TClassifyQuestion );
  ClassifyQuestion := TClassifyQuestion(Question);
  ClassifyQuestion.Right.Clear;
  SetLength(Answer, Length(FPlacement));
  for i := 0 to High(FPlacement) do
  begin
    ClassifyQuestion.Right.Add(ClassifyQuestion.Categories[
      FPlacement[i].CategoryIndex].Items[FPlacement[i].ItemIndex].Clone);
    Answer[i] := FPlacement[i].CategoryIndex;
  end;
  ClassifyQuestion.Response.SetAnswer(Answer);
  for i := 0 to ClassifyQuestion.CategoryCount-1 do
    ClassifyQuestion.Categories[i].Items.Clear;
end;

function TSpawnClassifyQuestionAlterant.GetPlacement: TClassifyPlacementInfoArray;
begin
  Result := Copy(FPlacement);
end;

procedure TSpawnClassifyQuestionAlterant.SetPlacement(
  const Value: TClassifyPlacementInfoArray);
begin
  FPlacement := Copy(Value);
end;

end.
